home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / n32kernel.t < prev    next >
Text File  |  1988-05-02  |  26KB  |  673 lines
  1. (herald n32kernel (env tsys))                                          ;86/12/21
  2.  
  3. ;;;  note that A1 must not be destroyed
  4. ;;;  return is in TP
  5.  
  6. (define (n32-big-bang)                                                 ;86/12/24
  7.   (lap (big_bang handle-stack-base
  8.          icall-bad-proc icall-wrong-nargs
  9.          handle-undefined-effect
  10.         really-gc pc-code-vector
  11.         heap-overflow-error call-fault-handler cont-wrong-nargs)
  12.  
  13.     (spri d nil-reg (d@r nil-reg slink/nil-cdr))   ; (cdr '()) = '()
  14.     (spri d nil-reg (d@r nil-reg slink/nil-car))   ; (car '()) = '()
  15.     (movi d P (d@r nil-reg slink/kernel))          ; save kernel pointer
  16.  
  17.     (addr (label %undefined-effect) (d@r nil-reg slink/undefined-effect))
  18.     (addr (label %make-pair)        (d@r nil-reg slink/make-pair))
  19.     (addr (label %make-extend)      (d@r nil-reg slink/make-extend))
  20.     (addr (label %nary-setup)       (d@r nil-reg slink/nary-setup))
  21.     (addr (label %set)              (d@r nil-reg slink/set))
  22.     (addr (label %icall)   (d@r nil-reg slink/icall))
  23.     (addr (label %cit-hack)   (d@r nil-reg slink/cit-hack))
  24.     (addr (label %cont-wrong-nargs) (d@r nil-reg slink/cont-wrong-nargs))
  25.     (addr (label %kernel-begin)     (d@r nil-reg slink/kernel-begin))
  26.     (addr (label %kernel-end)       (d@r nil-reg slink/kernel-end))
  27.  
  28.     ;; initialize root process, stored in outer space?  
  29.  
  30.     ;; zero out extra registers
  31.     (movi d ($ temp-block-size) S0)
  32. initialize-loop     
  33.     (movi d ($ 0) (tos))
  34.     (subi d ($ 4) S0)
  35.     (cmpi d S0 ($ 0))
  36.     (j> initialize-loop)
  37.  
  38.     (spri d SP A3)                                  ; load task reg
  39.     (lpri d TASK A3)                                ; in a roundabout way
  40.     (adjspi d ($ (fx- 0 (fx+ %%task-header-offset 4))))    ; allocate task block
  41.     (movi d ($ header/task) (tos))                    ; task header
  42.     (spri d SP A3)
  43.     (addi d ($ 2) A3)
  44.     (movi d A3 (d@r nil-reg slink/root-process))      ; ptr to root and
  45.     (movi d A3 (d@r nil-reg slink/current-task))      ; current process
  46.  
  47.     ;; initialize stack
  48.     (movi d A3 (tos))                                 ; task block
  49.     (spri d nil-reg (tos))                            ; no parent
  50.     (movi d ($ 0) (tos))                              ; active, no current sz
  51.     (movi d ($ (fixnum-ashl %%stack-size 2)) (tos))   ; total stack size
  52.     (movi d ($ #xBADBAD) (tos))                       ; distinguished value
  53.     (addr (label stack-base-template) (tos))          ; stack base
  54.  
  55.     ;; initialize root process
  56. ;++       (spri d SP A3)
  57. ;++       (addi d ($ 2) A3)
  58. ;++       (movi d A3 (d@r TASK task/stack))       ; set stack in root-process
  59. ;++       what to do; task/stack is a fixnum not an extend as it should be!
  60.     (spri d SP (d@r TASK task/stack))
  61.     (movi d ($ 0) (d@r TASK task/extra-pointer))
  62.     (movi d ($ 0) (d@r TASK task/extra-scratch))
  63.     (movi d ($ 0) (d@r TASK task/scratch))
  64.     (spri d nil-reg (d@r TASK task/dynamic-state))
  65.     (spri d nil-reg (d@r TASK task/doing-gc?))
  66.     (movi d ($ 0) (d@r TASK task/foreign-call-cont))
  67.     (movi d ($ 0) (d@r TASK task/critical-count))
  68.     (spri d nil-reg (d@r TASK task/k-list))
  69.     (spri d nil-reg (d@r TASK task/gc-weak-set-list))
  70.     (spri d nil-reg (d@r TASK task/gc-weak-alist-list))
  71.     (spri d nil-reg (d@r TASK task/gc-weak-table-list))
  72.     (spri d nil-reg (d@r nil-reg slink/snapper-freelist))
  73.     (spri d nil-reg (d@r nil-reg slink/pair-freelist))
  74.     (movi d (d@r P (static 'big_bang)) P)
  75.     (movi d (d@r p 2) p)
  76.     (jump (@r TP))
  77.  
  78.  
  79. %make-pair
  80.     ;; return pair in AN
  81.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  82.     (movi d (d@r TASK task/area-frontier) AN)     ; AN is old frontier
  83.     (addi d ($ 8) AN)                             ; cons 2 slots
  84.     (cmpi d AN (d@r TASK task/area-limit))
  85.     (j> %make-pair-heap-overflow)
  86. %make-pair-continue
  87.     (movi d AN (d@r TASK task/area-frontier))     ; update frontier
  88.     (subi d ($ (fx- 8 tag/pair)) AN)              ; return pair pointer
  89.     (movi d ($ 0) (d@r AN (fx- 0 tag/pair)))      ; zero out CDR
  90.     (movi d ($ 0) (d@r AN (fx- 4 tag/pair)))      ; zero out CAR
  91.     (bici b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3))) ; re-enable
  92.     (cmpi b ($ 0) (d@r TASK (fx+ task/critical-count 3)))
  93.     (jn= %deferred-interrupts)
  94.     (ret ($ 0))
  95.  
  96. %make-pair-heap-overflow
  97.     (movi d ($ header/true) (d@r TASK task/doing-gc?))
  98.     (jsr (label %heap-overflow))
  99.     (movi d (d@r TASK task/area-frontier) AN)
  100.     (addi d ($ 8) AN)
  101.     (cmpi d AN (d@r TASK task/area-limit))
  102.     (j> %horrible-heap-overflow)
  103.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  104.     (spri d nil-reg (d@r TASK task/doing-gc?))
  105.     (jbr %make-pair-continue)
  106.  
  107. %make-extend
  108.     ;; receive descriptor in An, size in S0, return extend in AN
  109.     ;; NARGS is extra scratch reg
  110.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  111.     (movi d (d@r TASK task/area-frontier) NARGS)  ; NARGS is old area-frontier
  112.     (addi d ($ 4) S0)                             ; add one for the descriptor
  113.     (addi d NARGS S0)                             ; S0 now new frontier
  114.     (cmpi d S0 (d@r TASK task/area-limit))
  115.     (j> %make-extend-heap-overflow)
  116. %make-extend-continue
  117.     (movi d S0 (d@r TASK task/area-frontier))     ; update frontier
  118.     (movi d AN (@r NARGS))                        ; move in descriptor
  119.     (movi d NARGS AN)                             ; return extend pointer
  120.     (jbr extend-test)
  121. extend-loop                                       ; zero out storage
  122.     (movi d ($ 0) (@r NARGS))                     ; clear slot
  123. extend-test
  124.     (addi d ($ 4) NARGS)                          ; next slot (NARGS is counter)
  125.     (cmpi d S0 NARGS)                             ; if at frontier
  126.     (j> extend-loop)                              ; loop  
  127.     (addi d ($ tag/extend) AN)
  128.     (bici b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  129.     (cmpi b ($ 0) (d@r TASK (fx+ task/critical-count 3)))
  130.     (jn= %deferred-interrupts)
  131.     (ret ($ 0))
  132.  
  133. %make-extend-heap-overflow
  134.     (movi d ($ header/true) (d@r TASK task/doing-gc?))
  135.     (subi d NARGS S0)                             ; S0 now size+1 again
  136.     (jsr (label %heap-overflow))
  137.     (movi d (d@r TASK task/area-frontier) NARGS)  ; get post-gc area-frontier
  138.     (addi d NARGS S0)                             ; S0 now new frontier
  139.     (cmpi d S0 (d@r TASK task/area-limit))
  140.     (j> %horrible-heap-overflow)
  141.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  142.     (spri d nil-reg (d@r TASK task/doing-gc?))
  143.     (jbr %make-extend-continue)
  144.  
  145.  
  146. %heap-overflow   
  147.     (movi d S0 (tos))                               ; save scratch registers
  148.     (movi d NARGS (tos))
  149.     (movi d ($ (fx/ temp-block-size 4)) S0)
  150. save-loop                                           ; save temps
  151.     (movi d (index-d (d@r TASK -4) S0) (tos))
  152.     (subi d ($ 1) S0)
  153.     (cmpi d S0 ($ 0))
  154.     (j>= save-loop)
  155.     (movi d TP (tos))                               ; save pointer registers
  156.     (movi d AN (tos))
  157.     (movi d A3 (tos))
  158.     (movi d A2 (tos))
  159.     (movi d A1 (tos))
  160.     (movi d P (tos))
  161.     (movi d (d@r SP (* (+ *no-of-registers* 3) 4)) A1)   ; one for TP 2 return ;++
  162.     (addr (label pc-check-return) (tos))          ; continuation
  163.     (movi d (d@r nil-reg slink/kernel) P)
  164.     (movi d (d@r P (static 'pc-code-vector)) P)
  165.     (movi d (d@r p 2) p)
  166.     (movi d (d@r P -2) TP)
  167.     (jump (@r TP))                               ; call pc-code-vector
  168.  
  169. ;;; the template header byte has high bit set if nary
  170.  
  171. %cit-hack
  172.     (movi d (d@r tp 6) an)   ; get auxilliary template
  173.     (jump (@r an))           
  174.  
  175. %icall
  176.     (movi w P S0)
  177.     (andi b ($ #b11) S0)
  178.     (cmpi b ($ tag/extend) S0)                      ; check ptr to closure is extend
  179.     (jn= %icall-bad-proc)
  180.     (movi d (d@r P -2) TP)                          ; fetch template header
  181.     (movi w TP S0)
  182.     (andi b ($ 3) S0)                               ; check header is extend
  183.     (cmpi b ($ tag/extend) S0)
  184.     (jn= %icall-bad-proc)
  185.     (cmpi b (d@r TP -2) ($ header/template))        ; check header is template
  186.     (jn= %icall-check-nary)
  187.     (cmpi b (d@r TP template/nargs) NARGS)          ; check number of args
  188.     (j= %icall-ok)
  189.     (jbr %icall-wrong-nargs)
  190. %icall-check-nary
  191.     (cmpi b (d@r TP -2) ($ (fx+ header/template 128)))   ; nary if high bit set
  192.     (jn= %icall-bad-proc)
  193.     (cmpi b (d@r TP template/nargs) NARGS)
  194.     (j> %icall-wrong-nargs)
  195. %icall-ok
  196.     (jump (@r TP))
  197.   
  198. %icall-bad-proc
  199.   (movi d a1 (d@r TASK task/t0))
  200.   (movi d a2 (d@r TASK (fx+ task/t0 4)))
  201.   (movi d a3 (d@r TASK (fx+ task/t0 8)))
  202.   (movi d ($ 0) s0)
  203.   (jsr (label %nary-setup))
  204.   (movi d an a2)
  205.   (movi d p a1)
  206.   (movi d (d@r nil-reg slink/kernel) P)
  207.   (movi d (d@r P (static 'icall-bad-proc)) P)
  208.   (movi d (d@r p 2) p)
  209.   (movi d (d@r P -2) TP)
  210.   (jump  (@r TP))
  211.  
  212. %icall-wrong-nargs
  213.   (movi d a1 (d@r TASK task/t0))
  214.   (movi d a2 (d@r TASK (fx+ task/t0 4)))
  215.   (movi d a3 (d@r TASK (fx+ task/t0 8)))
  216.   (movi d ($ 0) s0)
  217.   (jsr (label %nary-setup))
  218.   (movi d an a2)
  219.   (movi d p a1)
  220.   (movi d (d@r nil-reg slink/kernel) P)
  221.   (movi d (d@r P (static 'icall-wrong-nargs)) P)
  222.   (movi d (d@r p 2) p)
  223.   (movi d (d@r P -2) TP)
  224.   (jump  (@r TP))
  225.  
  226.  
  227. %deferred-interrupts                            ; Build fault frame
  228.     (movi d S0 (tos))                           ; save scratch registers
  229.     (movi d NARGS (tos))
  230.     (movi d ($ (fx/ (fx+ temp-block-size 8) 4)) S0)
  231. %int-save-loop                                  ; save temps and extra p and s
  232.     (movi d (index-d (d@r TASK -12) S0) (tos))  ; and task/scratch
  233.     (subi d ($ 1) S0)
  234.     (cmpi d S0 ($ 0))
  235.     (j>= %int-save-loop)
  236.     (movi d TP (tos))                           ; save pointer registers
  237.     (movi d AN (tos))
  238.     (movi d A3 (tos))
  239.     (movi d A2 (tos))
  240.     (movi d A1 (tos))
  241.     (movi d P (tos))
  242.     (movi d ($ 0) (tos))                        ; pc
  243.     (movi d (d@r SP (fx* 4 (+ *pointer-temps* *scratch-temps* 12))) (tos))
  244.                        ;; 12 = 2 (scratch regs) + 6 (pointer regs) + 1 (pc)
  245.                        ;;    + 3 (extra p & s & task/scratch)
  246.     (movi d ($ 0) (tos))                        ; # of pointers on stack was 0
  247.     (movi d ($ (+ (fixnum-ashl (+ *pointer-temps* *scratch-temps* 14) 8)
  248.                 header/fault-frame))            ; fault frame header
  249.           (tos))
  250.     (addr (label %int-return) (tos))            ; continuation
  251.     (movi d (d@r nil-reg slink/kernel) P)
  252.     (movi d (d@r P (static 'call-fault-handler)) P)
  253.     (movi d (d@r p 2) p)
  254.     (movi d (d@r P -2) TP)
  255.     (jump (@r TP))
  256.  
  257.  
  258. %kernel-begin
  259.  
  260. %cont-wrong-nargs
  261.   (negi d nargs nargs)
  262.   (movi d a1 (d@r TASK task/t0))
  263.   (movi d a2 (d@r TASK (fx+ task/t0 4)))
  264.   (movi d a3 (d@r TASK (fx+ task/t0 8)))
  265.   (movi d ($ 0) s0)
  266.   (jsr (label %nary-setup))
  267.   (movi d an a2)
  268.   (addr (d@r sp 2) a1)
  269.   (movi d (d@r nil-reg slink/kernel) P)
  270.   (movi d (d@r P (static 'cont-wrong-nargs)) P)
  271.   (movi d (d@r p 2) p)
  272.   (movi d (d@r P -2) TP)
  273.   (jump  (@r TP))
  274.                 
  275. %post-gc-nary-setup
  276.     (movi d ($ -1) (d@r TASK task/extra-scratch))   ; -1 if post-gc
  277.     (jbr %real-nary-setup)                   
  278.  
  279. %nary-setup                                         ; # of required args in S0
  280.     (movi d ($ 0) (d@r TASK task/extra-scratch))
  281. %real-nary-setup
  282.     (subi d ($ 2) NARGS)                            ; now NARGS = #args - 1
  283.     (movi d P (d@r TASK task/extra-pointer))        ; save P, use it as working reg
  284.     (spri d nil-reg AN)                             ; why??
  285.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  286.     (jbr %nary-test)
  287. %nary-loop                                          ; cons the argument list
  288.     (movi d AN P)                                   ; accumulate in P
  289.     (movi d (d@r TASK task/area-frontier) AN)       ; AN is old frontier
  290.     (addi d ($ 8) AN)                               ; cons 2 slots
  291.     (cmpi d AN (d@r TASK task/area-limit))
  292.     (j> %nary-make-pair-heap-overflow)
  293. %nary-make-pair-continue
  294.     (movi d AN (d@r TASK task/area-frontier))       ; update frontier
  295.     (subi d ($ (fx- 8 tag/pair)) AN)                ; return pair pointer
  296.     (movi d ($ 0) (d@r AN (fx- 0 tag/pair)))        ; zero out CDR
  297.     (movi d P (d@r AN -3))                          ; set cdr
  298.     (movi d (index-d (@r TASK) NARGS) (d@r AN 1))   ; set car
  299.     (subi d ($ 1) NARGS)
  300. %nary-test
  301.     (cmpi d NARGS S0)
  302.     (j>= %nary-loop)
  303.     (cmpi d ($ 0) (d@r TASK task/extra-scratch))
  304.     (jn= %nary-clear-extras)
  305.     (movi d (d@r TASK task/extra-pointer) P)     ; restore P and return
  306.     (bici b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  307.     (cmpi b ($ 0) (d@r TASK (fx+ task/critical-count 3)))
  308.     (jn= %deferred-interrupts)
  309.     (ret ($ 0))
  310. %nary-clear-extras                               ; if more args than A registers, 
  311.     (cmpi d ($ 3) S0)                            ; they're in memory.  Clear.
  312.     (j<= foo45)
  313.     (movi d ($ 3) S0)
  314. foo45
  315.     (movi d ($ 0) (index-d (@r TASK) S0))
  316.     (addi d ($ 1) S0)
  317.     (cmpi d ($ (fx/ temp-block-size 4)) S0)         ; why clear whole block??
  318.     (j> foo45)
  319.     (addr (label %nary-setup) (d@r nil-reg slink/nary-setup))  ; why?? redundant?
  320.     (movi d (d@r TASK task/extra-pointer) P)                            
  321.     (bici b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  322.     (cmpi b ($ 0) (d@r TASK (fx+ task/critical-count 3)))
  323.     (jn= %deferred-interrupts)
  324.     (ret ($ 0))     
  325.  
  326. %nary-make-pair-heap-overflow
  327.     (movi d ($ header/true) (d@r TASK task/doing-gc?))
  328.     (jsr (label %heap-overflow))
  329.     (movi d (d@r TASK task/area-frontier) AN)
  330.     (addi d ($ 8) AN)
  331.     (cmpi d AN (d@r TASK task/area-limit))
  332.     (j> %horrible-heap-overflow)
  333.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  334.     (spri d nil-reg (d@r TASK task/doing-gc?))
  335.     (jbr %nary-make-pair-continue)
  336.  
  337. %set                                        ; a location is (unit  . index)
  338.    ;;  vcell in extra-pointer
  339.    (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  340.    (movi d s0 (tos))
  341.    (movi d an (tos))
  342.    (movi d a3 (tos))
  343.    (movi d a2 (tos))
  344.    (movi d a1 (tos))
  345.    (movi d p (tos))
  346.    (movi d (d@r TASK task/extra-pointer) a3)
  347.    (movi d (d@r A3 6) A1)                  ; get locations
  348.    (movi d (d@r A1 2) A1)                  ; get the vector in A1
  349.    (movi d (d@r A1 -2) S0)
  350.    (ashi d ($ -8) S0)                        ; length in S0
  351.    (jbr %set-test)
  352. %set-loop
  353.    (movi d (d@r nil-reg slink/snapper-freelist) an)
  354.    (cmpi d an (d@r nil-reg 1))
  355.    (j= cons-snapper)
  356.    (movi d (d@r an 1) p)
  357.    (movi d (d@r an -3) (d@r nil-reg slink/snapper-freelist))
  358.    (movi d (d@r nil-reg slink/pair-freelist) (d@r an -3))
  359.    (movi d an (d@r nil-reg slink/pair-freelist))
  360. %real-top
  361.    (movi d (index-d (d@r A1 -6) S0) A2)      ; get unit
  362.    (movi d (index-d (d@r A1 -2) S0) AN)      ; get index
  363.    (movi d (d@r a3 2) (d@r p 2))
  364.    (movi d a2 (d@r p 6))
  365.    (movi d an (d@r p 10))
  366.    (movi d p (index-b (d@r A2 2) AN))
  367.    (subi d ($ 2) S0)
  368. %set-test
  369.    (cmpi d ($ 0) S0)
  370.    (jn= %set-loop)
  371.    (movi d (tos) p)
  372.    (movi d (tos) a1)
  373.    (movi d (tos) a2)
  374.    (movi d (tos) a3)
  375.    (movi d (tos) an)
  376.    (movi d (tos) s0)
  377.    (bici b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  378.    (cmpi b ($ 0) (d@r TASK (fx+ task/critical-count 3)))
  379.    (jn= %deferred-interrupts)
  380.    (ret ($ 0))
  381. cons-snapper
  382.    (movi d (d@r TASK task/area-frontier) AN)
  383.    (addi d ($ 16) AN)
  384.    (cmpi d AN (d@r TASK task/area-limit))
  385.    (j> %set-heap-overflow)
  386. %set-continue                        ; lose, lose
  387.    (movi d AN (d@r TASK task/area-frontier))
  388.    (addr (d@r an -14) p)
  389.    (addr (label link-snapper) a2)
  390.    (movi d a2 (d@r p -2))
  391.    (jbr %real-top)
  392. %set-heap-overflow
  393.     (movi d ($ header/true) (d@r TASK task/doing-gc?))
  394.     (movi d ($ (+ (fixnum-ashl 5 16) (fixnum-ashl 1 8) header/vframe )) (tos))
  395.     (movi d (d@r sp 24) (tos))
  396.     (jsr (label %heap-overflow))
  397.     (movi d (@r sp) (d@r sp 28))
  398.     (adjspi b ($ -8))
  399.     (movi d (d@r TASK task/area-frontier) AN)
  400.     (addi d ($ 16) AN)
  401.     (cmpi d AN (d@r TASK task/area-limit))
  402.     (j> %horrible-heap-overflow)
  403.     (ori b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))  ; defer int's
  404.     (spri d nil-reg (d@r TASK task/doing-gc?))
  405.     (jbr %set-continue)
  406.  
  407. %kernel-end
  408.         
  409. %horrible-heap-overflow
  410.     (adjspi b ($ -4))
  411.     (bici b ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  412.     (spri d nil-reg (d@r TASK task/doing-gc?))
  413.     (movi d (d@r nil-reg slink/kernel) P)
  414.     (movi d (d@r P (static 'heap-overflow-error)) P)
  415.     (movi d (d@r p 2) p)
  416.     (movi d (d@r P -2) TP)
  417.     (jump (@r TP))
  418.   
  419. %undefined-effect
  420.     (movi d TP A2)              ; template
  421.     (movi d (d@r nil-reg slink/kernel) P)
  422.     (movi d (d@r P (static 'handle-undefined-effect)) P)
  423.     (movi d (d@r p 2) p)
  424.     (movi d (d@r P -2) TP)
  425.     (adjspi b ($ -4))
  426.     (jump (@r TP))
  427.  
  428.   ))
  429.  
  430. (lap-template (0 0 -1 t stack %int-return-handler)                     ;86/12/24
  431. %int-return
  432.     (ori b ($ #b01000000) (d@r TASK (fx+ task/critical-count 3)))  ; disable int's
  433.         ;; 16 = 2 (scratch regs) + 3 (extra p & s & task/scratch) 
  434.         ;;    + 6 (pointer regs) + 1 (pc)
  435.         ;;    + 4 (hack top, pointers on stack, header, template)
  436.     (movi d (d@r SP 12) (d@r SP (* (+ *pointer-temps* *scratch-temps* 16) 4)))
  437.     (adjspi b ($ -20))  ; pop template, header, pointers on stack, hack top, pc
  438.     (movi d (tos) P)
  439.     (movi d (tos) A1)
  440.     (movi d (tos) A2)
  441.     (movi d (tos) A3)
  442.     (movi d (tos) AN)
  443.     (movi d (tos) TP)
  444.     (movi d ($ -3) S0)
  445. %int-return-restore-loop                                  ; restore temps
  446.     (movi d (tos) (index-d (@r TASK) S0))
  447.     (addi d ($ 1) S0)
  448.     (cmpi d ($ (fx/ temp-block-size 4)) S0)
  449.     (j> %int-return-restore-loop)
  450.     (movi d (tos) NARGS)
  451.     (movi d (tos) S0)
  452.     (bici b ($ #b01000000) (d@r TASK (fx+ task/critical-count 3)))
  453.     (ret ($ 0))
  454. %int-return-handler
  455.     (spri d nil-reg AN)
  456.     (ret ($ 0)))
  457.  
  458.  
  459.  
  460. (define (clear-extra-registers)                                        ;86/12/24
  461.   (lap ()
  462.     (movi d ($ -1) S0)
  463. zero-loop                                  ; restore temps
  464.     (movi d ($ 0) (index-d (@r TASK) S0))
  465.     (addi d ($ 1) S0)
  466.     (cmpi d ($ (fx/ temp-block-size 4)) S0)
  467.     (j> zero-loop)
  468.     (movi d ($ -2) NARGS)
  469.     (movi d (@r sp) tp)
  470.     (jump (@r tp))))
  471.            
  472.  
  473. (lap-template (0 0 -1 t stack pc-check-return-handler)                 ;86/12/24
  474. pc-check-return
  475.     (adjspi b ($ -4))                              ; pop return address
  476.     (movi d A1 (tos))                                   ; code vector of pc
  477.     (addr (d@r A1 -2) (tos))                          ; fixnumized code vector
  478.     (addr (label gc-template) (tos))                  ; continuation
  479.     (movi d (d@r nil-reg slink/kernel) P)
  480.     (movi d (d@r P (static 'really-gc)) P)
  481.     (movi d (d@r p 2) p)
  482.     (movi d (d@r P -2) TP)
  483.     (jump (@r TP))
  484. pc-check-return-handler
  485.     (spri d nil-reg AN)
  486.     (ret ($ 0)))
  487.  
  488.                  
  489. ;;; sizes of gc template:
  490. ;;; pointer -- n registers + n temps + 1 extra + 2 code vector + tp
  491. ;;; scratch -- gc return address + 1 other + n registers + n temps
  492.  
  493. (lap-template ((+ *pointer-temps* *pointer-registers* 4)               ;86/12/24
  494.                (+ *scratch-temps* *scratch-registers* 2) 
  495.                -1 t stack gc-template-handler)       ;; see gc.t
  496. gc-template
  497.     (addr (label %post-gc-nary-setup) (d@r nil-reg slink/nary-setup))
  498.     (adjspi b ($ -4))                                ; pop template 
  499.     (movi d (tos) S0)                                ; pop old code (fixnum)
  500.     (movi d (tos) NARGS)                             ; pop relocated code
  501.     (cmpi d NARGS (d@r nil-reg slink/nil-car))       ; (NARGS is extra scratch)
  502.     (j= gc-continue)                                 ; not relocated
  503.     (subi d ($ tag/extend) NARGS)                    ; fixnumize new code
  504.     (subi d S0 NARGS)                                       ; delta pc
  505.     (addi d NARGS (d@r SP (* (+ *no-of-registers* 3) 4)))   ; update pc
  506. gc-continue
  507.     (movi d (tos) P)
  508.     (movi d (tos) A1)
  509.     (movi d (tos) A2)
  510.     (movi d (tos) A3)
  511.     (movi d (tos) AN)
  512.     (movi d (tos) TP)
  513.     (movi d ($ -1) S0)
  514. restore-loop                                            ; restore temps
  515.     (movi d (tos) (index-d (@r TASK) S0))
  516.     (addi d ($ 1) S0)
  517.     (cmpi d ($ (fx/ temp-block-size 4)) S0)
  518.     (j> restore-loop)
  519.     (movi d (tos) NARGS)
  520.     (movi d (tos) S0)
  521.     (ret ($ 0))
  522. gc-template-handler
  523.     (spri d nil-reg AN)
  524.     (ret ($ 0)))
  525.   
  526. (lap-template (0 0 0 nil stack stack-base-handler)                     ;86/12/24
  527. stack-base-template
  528.     (jump (*d@r nil-reg slink/undefined-effect))
  529. stack-base-handler
  530.     (movi d (d@r nil-reg slink/kernel) AN)
  531.     (movi d (d@r AN (static 'handle-stack-base)) A1)
  532.     (movi d (d@r a1 2) a1)
  533.     (jump (*d@r nil-reg slink/dispatch-label)))
  534.       
  535.   
  536.  
  537. (define (lap-relocate frame old-tp new-tp offset)                      ;86/12/27
  538.   (lap ()                 
  539.     (movi d (d@r TASK 12) S0)                ; offset (4th arg)
  540.     (movi d (index-b (d@r A1 2) S0) NARGS)   ; code (NARGS is extra scratch)
  541.     (subi d A2 NARGS)                        ; code-offset
  542.     (addi d NARGS A3)                        ; new code
  543.     (movi d A3 (index-b (d@r A1 2) S0))
  544.     (movi d ($ -1) NARGS)
  545.     (movi d (@r sp) tp)
  546.     (jump (@r tp))))
  547.  
  548. (define (current-task)                                                 ;86/12/27
  549.   (lap ()
  550.     (spri d TASK A1)
  551.     (addi d ($ (fx+ %%task-header-offset 2)) A1)   ; offset is negative !
  552.     (movi d ($ -2) NARGS)
  553.     (movi d (@r sp) tp)
  554.     (jump (@r tp))))
  555.  
  556.  
  557. ; debugger hacks
  558.  
  559. (define (@@ address)    ; randomness                                   ;86/12/27
  560.   (lap ()
  561.     (addi d ($ 2) A1)
  562.     (movi d ($ -2) NARGS)
  563.     (movi d (@r sp) tp)
  564.     (jump (@r tp))))
  565.  
  566.  
  567. (define-foreign gc_interrupt (gc_interrupt) ignore)                    ;86/12/27
  568.  
  569. (define (crawl-exhibit-fault-frame frame)                              ;86/12/27
  570.   (cond ((not (foreign-fault-frame? frame))       ; foreign
  571.          (print-register frame 'p 3)
  572.          (print-register frame 'a1 4)
  573.          (print-register frame 'a2 5)
  574.          (print-register frame 'a3 6)
  575.          (print-register frame 'an 7)
  576.          (print-register frame 'tp 8))
  577.         (else
  578.          (format t " In foreign code; no information available~%"))))
  579.  
  580.  
  581. (define (trace-fault-frame frame)                                      ;86/12/27
  582.   (cond ((alt-bit-set? frame)          
  583.          (move-object (make-pointer frame 0)))           ; foreign cont
  584.         (else
  585.          (let ((tp (extend-elt frame 8)))                ; old TP
  586.            (trace-pointers (make-pointer frame 2) 
  587.                            (fx+ *pointer-registers* 1))  ; trace registers
  588.            (trace-pointers                               ; trace temps
  589.             (make-pointer frame (fx+ *pointer-registers* 5))
  590.                     ; 5 = #point,hacktos,pc,ex-scr,scr
  591.             (fx+ *pointer-temps* 1))
  592.            (let ((ptrs (extend-elt frame 0))             ; trace top of stack
  593.                  (size (fault-frame-slots frame)))
  594.              (trace-pointers (make-pointer frame (fx- size 1)) ptrs))
  595.            (if (eq? (extend-elt frame 1) 0)              ; hack-top-of-stack?
  596.                (relocate-random-code frame 2 tp)         ; relocate PC
  597.                (relocate-random-code frame 1 tp))))))    ; relocate top-of-stack
  598.  
  599. (define (relocate-random-code frame offset old-tp)                     ;86/12/27
  600.   (if (in-old-space? (extend-elt frame offset))
  601.       (lap-relocate frame 
  602.                     old-tp 
  603.                     (extend-elt frame (fx+ *pointer-registers* 3)) 
  604.                     offset)))
  605.  
  606. (define (make-link-snapper value unit i)
  607.   (lap ()
  608.     (movi d (d@r nil-reg slink/snapper-freelist) p)
  609.     (cmpi d p (d@r nil-reg 1))
  610.     (j= cons-snapper-1)
  611.     (movi d (d@r p 1) an)
  612.     (movi d (d@r p -3) (d@r nil-reg slink/snapper-freelist))
  613.     (movi d (d@r nil-reg slink/pair-freelist) (d@r p -3))
  614.     (movi d p (d@r nil-reg slink/pair-freelist))
  615. foobarfoo
  616.     (movi d a1 (d@r an 2))
  617.     (movi d a2 (d@r an 6))
  618.     (movi d a3 (d@r an 10))
  619.     (movi d an a1)
  620.     (movi d ($ -2) nargs)
  621.     (movi d (@r sp) tp)
  622.     (jump (@r tp))
  623. cons-snapper-1    
  624.     (addr (label link-snapper) an)
  625.     (movi d ($ 12) S0)
  626.     (jsr (label %make-extend))
  627.     (jbr foobarfoo)))
  628.  
  629. (define *link-snapper-template*
  630. (lap-template (3 0 1 t heap handle-snapper)
  631. link-snapper
  632.   (movi d p an)
  633.   (movi d (d@r p 2) p)
  634.     (movi w P S0)
  635.     (andi b ($ #b11) S0)
  636.     (cmpi b ($ tag/extend) S0)                      ; check ptr to closure is extend
  637.     (jn= %icall-bad-proc)
  638.     (movi d (d@r P -2) TP)                          ; fetch template header
  639.     (movi w TP S0)
  640.     (andi b ($ 3) S0)                               ; check header is extend
  641.     (cmpi b ($ tag/extend) S0)
  642.     (jn= %icall-bad-proc)
  643.     (cmpi b (d@r TP -2) ($ header/template))        ; check header is template
  644.     (jn= %icall-check-nary-l)
  645.     (cmpi b (d@r TP template/nargs) NARGS)          ; check number of args
  646.     (j= snap-link)
  647.     (jbr %icall-wrong-nargs)
  648. %icall-check-nary-l
  649.     (cmpi b (d@r TP -2) ($ (fx+ header/template 128)))   ; nary if high bit set
  650.     (jn= %icall-bad-proc)
  651.     (cmpi b (d@r TP template/nargs) NARGS)
  652.     (j> %icall-wrong-nargs)
  653. snap-link
  654.   (movi d an (d@r task task/extra-pointer))
  655.   (movi d (d@r an 10) s0)
  656.   (movi d (d@r an 6) an)
  657.   (movi d p (index-b (d@r an 2) s0))
  658.   (movi d (d@r nil-reg slink/pair-freelist) an)
  659.   (cmpi d an (d@r nil-reg 1))
  660.   (j= cons-pair)
  661.   (movi d (d@r an -3) (d@r nil-reg slink/pair-freelist))
  662. consed-pair
  663.   (movi d (d@r task task/extra-pointer) (d@r an 1))
  664.   (movi d (d@r nil-reg slink/snapper-freelist) (d@r an -3))
  665.   (movi d an (d@r nil-reg slink/snapper-freelist))
  666.   (jump (@r TP))
  667. cons-pair
  668.   (jsr (label %make-pair))
  669.   (jbr consed-pair)
  670. handle-snapper
  671.   (spri d nil-reg AN)
  672.   (ret ($ 0))))
  673.